Magnum One/Magnum One (Mid-American Digital) (Disc Manufacturing).iso/d4/check6.arc/TURPROCS.TUR

Text File | 1988-06-26 | 22.3 KB | 638 lines

{  SCREEN SCULPTOR(C)
   (C) COPYRIGHT, THE SOFTWARE BOTTLING COMPANY OF NEW YORK, 1984
   WARNING: Do not attempt to make any changes to this procedure unless you
   have made a backup. The Software Bottling Company Of New York can not
   and will not support such changes made to this program.
** Turbo Pascal Version, Trade Mark Of Borland International }

TYPE
     RECPACKSS = record
                 AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags: INTEGER;
               end;

VAR  regsSS : RECPACKSS;


TYPE
      video_pointerSS = array[1..3840] of CHAR;
VAR
{ Video Variables  Set By SET_VIDEO_TYPE procedure in SETMON.TUR }
      vcolorSS, voffSS, vonSS: byte; vdispSS: INTEGER; videoSS: ^video_pointerSS;

PROCEDURE BEEP(BeepOn: BOOLEAN);
BEGIN
  if BeepOn then write(chr(7));
END;

{ IF YOU HAVE VERSION 1 OF Turbo Pascal Then Replace The Following
  COLOR & WRITEC PROCEDURES WITH THE CONTENTS OF 'COLORV1.TUR'
  FILE
}

PROCEDURE COLOR(foregr,backgr: BYTE);
{ Select current color by setting Foreground and Background
  Any values between 0 and 15 are acceptable. See Tech Ref Manual
}
  BEGIN
    if backgr>7 then foregr:=foregr+16;         { <======= TURBO Version 2}
    TextColor(foregr); TextBackground(backgr);  { <======= TURBO Version 2}
  END; { COLOR }

PROCEDURE WRITEC(vtext: STR80);
  BEGIN
    write(vtext);
  END; { WRITEC }

PROCEDURE CLEAR_KBD;
{ Clear Type Ahead Characters From Keyboard }
VAR kchar: CHAR;
BEGIN
  while keypressed do read(kbd,kchar);
END; { CLEAR_KBD }

FUNCTION  SET_MONITOR_TYPE: INTEGER;
{ Determine The Type Of Monitor Being Used }
VAR j : INTEGER;

  PROCEDURE CURSOR_SET;
  { Set Cursor Size }
  VAR v1,v2: INTEGER;
  BEGIN
  if j=2 then begin v1:=$3d4; v2:=$3d5 end
  else begin v1:=$3b4; v2:=$3b5 end;
  if (j=2) or (j=3) then
  begin
    port[v1]:=$0A; port[v2]:=0; { Set High Cursor Scan Line }
    port[v1]:=$0B; port[v2]:=7; { Set Low Cursor Scan Line }
  end;
  END; { CURSOR_SET }

BEGIN
  j:=mem[$40:$10]; { Figure out the monitor type }
  j:=(j and $0030) DIV 16;
  CASE j OF
    0: begin writeln('Illegal Monitor Mode'); halt end;
    1: begin { Set 40 column color to 80 column color }
         writeln('Use MODE command to set to 80. ( MODE CO80 )'); halt
       end;
    2: videoSS:=ptr($b800,0);  { Graphics 80 }
    3: videoSS:=ptr($b000,0);  { Monochrome }
  END;
  voffSS:=$1; vonSS:=$29; vdispSS:=$3d8;  { Video Off, On, Location }
  CURSOR_SET; { Set To A Large Cursor }
  COLOR(15,0); { Set Default Color }
  SET_MONITOR_TYPE:=j;
END; { SET_MONITOR_TYPE }

PROCEDURE DISPLAY_SCREEN(screen_name: str80; var exist: boolean);
{ Load Screen From Disk. Display To Monitor }
VAR bload: array[1..3968] of CHAR;
    scrname: FILE;

    PROCEDURE VIDEO_OFF; { Turn Video Off }
      BEGIN port[vdispSS]:=voffSS; END;

    PROCEDURE VIDEO_ON; { Turn Video On }
      BEGIN port[vdispSS]:=vonSS; END;
BEGIN
  assign(scrname,screen_name);  {$I-} reset(scrname); {$I+}
  if IOresult=0 then
  begin
    exist:=TRUE; blockread(scrname,bload[1],filesize(scrname)); close(scrname);
    VIDEO_OFF; move(bload[8],videoSS^,3840); VIDEO_ON;
  end else exist:=FALSE;
END; { DISPLAY_SCREEN }


{ See SCREEN SCULPTOR Manual For A Description Of GETITEM }
PROCEDURE GETITEM(
                  COL,LIN,LEN :         BYTE;
                  ITYPE :               CHAR;
              VAR WITEM :               STR80;
                  PICT :                STR80;
                  ITEM_LOW,ITEM_HIGH :  STR80;
              VAR RET :                 STR2;
                  RETRIEVE :            BOOLEAN;
                  FGR_COLOR,BGR_COLOR : BYTE
                  );

TYPE
  PICT_TYPE = set of CHAR;
CONST
  confirm=FALSE; { If FALSE auto-skip to next field when field is filled }
  l='K'; r='M'; u='H'; d='P'; dl='S'; ins='R'; pu='I'; pd='Q';
      { Define The Function Keys }
  f1=';'; f2='<'; f3='='; f4='>'; f5='?';
  f6='@'; f7='A'; f8='B'; f9='C'; f10='D';
  special_keys: PICT_TYPE = [l,r,u,d,dl,ins,pu,pd];
  pict_elements: PICT_TYPE = ['X','U','L','#','9','8'];
  bk: BYTE=8; esc: BYTE=27; cr: BYTE=13;
VAR
  hcol,pcol,tcol,pict_dec,item_dec,tempb1,tempb2,plen,ilen: BYTE;
  kchar: str2; range_check,clear25: BOOLEAN;
  check,end_of_field,begin_of_field,sign_flag,
  special,dec_flag,valid_char: BOOLEAN;
  temp_item, item: STR80;
  fchar: CHAR;


PROCEDURE FILLCHAR(var temp_item: STR80; tempb1: BYTE; fchar: CHAR);
{ Fills a variable with a number of fchar }
VAR i: integer;
BEGIN
for i:=1 to tempb1 do temp_item[i]:=fchar; temp_item[0]:=chr(tempb1);
END; { FILLCHAR PROCEDURE }


FUNCTION DATE_CHECK(datevar: STR80): BOOLEAN;
{ Checks For Date Validity Excluding  the following:
  Does not check Leap Years. If datevar is correct the DATE_CHECK is TRUE }
CONST
    month_days: array[1..12] of INTEGER=(31,28,31,30,31,30,31,31,30,31,30,31);
VAR mm,dd,yy: STR2;
    mmi,ddi,yyi: INTEGER;
    error: INTEGER;
    ch_date: BOOLEAN;
BEGIN
if ord(datevar[0])<>8 then
  DATE_CHECK:=FALSE
else
begin
  ch_date:=TRUE;
  mm:=copy(datevar,1,2); dd:=copy(datevar,4,2); yy:=copy(datevar,7,2);
  val(mm,mmi,error); if (error<>0) or (mmi<1) or (mmi>12) then ch_date:=FALSE;
  if ch_date then
  begin
    val(dd,ddi,error);
    if (error<>0) or (ddi<1) or (ddi>month_days[mmi]) then ch_date:=FALSE;
  end;
  if ch_date then
  begin
    val(yy,yyi,error); if error<>0 then ch_date:=FALSE;
  end;
  DATE_CHECK:=ch_date;
end;
END; { PROCEDURE DATE_CHECK }

FUNCTION CHECK_DATE(DATE, DATE_LOW, DATE_HIGH: STR80): BOOLEAN;
{ Check Validity If Date and whether it falls between low and high }
{ If low range date is higer than high range date then we assume }
{ we crossed centuries eg. 09/09/84 to 01/01/10 }
{ Also a null date is ignored }
CONST dnull = '  /  /  ';
VAR   ch_date: BOOLEAN;
BEGIN
if date<>dnull then ch_date:=DATE_CHECK(date) else ch_date:=TRUE;
if ch_date and (date<>dnull) and (date_low<>dnull) and (date_high<>dnull) then
begin
  if ch_date then ch_date:=DATE_CHECK(date_low);
  if ch_date then ch_date:=DATE_CHECK(date_high);
  if ch_date then
  begin
    date:=copy(date,7,2)+copy(date,1,6);
    date_low:=copy(date_low,7,2)+copy(date_low,1,6);
    date_high:=copy(date_high,7,2)+copy(date_high,1,6);
    if (date_low<=date_high) then             { Low Date < High Date }
    begin
       if (date<date_low) or (date>date_high) then ch_date:=FALSE
    end else                                 { Low Date  > High Date }
       if (date<date_low) and (date>date_high) then ch_date:=FALSE;
  end;
end;
if ch_date then CHECK_DATE:=TRUE else begin CHECK_DATE:=FALSE; end;
END; {PROCEDURE CHECK_DATE}

FUNCTION CHECK_RANGE(VAR item, item_low, item_high: STR80): BOOLEAN;
{ Check to see whether item is within and including low and high }
VAR itemr, lowr, highr: REAL;
    errori, errorl, errorh: INTEGER;
BEGIN
CHECK_RANGE:=TRUE;
val(item_low,lowr,errorl); val(item_high,highr,errorh); val(item,itemr,errori);
if (errorl=0) and (errorh=0) and (errori=0) then
begin
  if itemr<lowr then CHECK_RANGE:=FALSE
  else if itemr>highr then CHECK_RANGE:=FALSE;
end else
  CHECK_RANGE:=FALSE;
END; { PROCEDURE CHECK_RANGE }

PROCEDURE MESSAGE(mess_num: BYTE);
{ Displays A Message On Line 25 and sets global clear25 to TRUE }
VAR mess, temp_item: STR79; mess_length: INTEGER;
BEGIN
  COLOR(0,7);
  case mess_num of
  1: mess:='Only 0 thru 9 Allowed';
  2: mess:='Only 0 thru 9 or a space Allowed';
  3: mess:='BAD Date OR Not Within '+item_low+' & '+
            item_high+'. Use [Del] To Blank Out Digits.';
  4: mess:='Number Not Within '+item_low+' & '+item_high+' Range';
  5: mess:='Only 0 thru 9, decimal point OR - sign Allowed';
  6: mess:='Only Y or N Allowed';
  7: mess:='Only M or F Allowed';
  8: mess:='No More Room For Digits. Use [Del] key to remove';
  end; { case }
mess_length:=ord(mess[0]);
clear25:=TRUE;
fillchar(temp_item,79-mess_length,' '); mess:=mess+temp_item;
BEEP(BeepOnSS); gotoxy(1,25) ;writec(mess); gotoxy(hcol,lin);
COLOR(FGR_COLOR, BGR_COLOR); CLEAR_KBD;
END; {MESSAGE PROCEDURE}

FUNCTION  GETCHAR(ctype: CHAR; VAR kchar: STR2):BOOLEAN;
{ if GETCHAR=TRUE on return then kchar= (l r d u dl in pu pd esc cr bk)}
{ if GETCHAR=FALSE on return then kchar is alpha numeric chars }
{ ctype must be one of the following}
{ U=Uppercase, L=Lower Case, X=Any Char, 9=0..9,' ', #=0..9,-,+,. }
{ GETCHAR will filter out any control characters }
TYPE  PICT_TYPE = set of CHAR;
CONST esc = 27; cr = 13; bk = 8;
      l='K'; r='M'; u='H'; d='P'; dl='S'; ins='R'; pu='I'; pd='Q';
      f1=';';f2='<'; f3='='; f4='>'; f5='?';
      f6='@'; f7='A'; f8='B'; f9='C'; f10='D';
      special_keys: PICT_TYPE = [l,r,u,d,dl,ins,pu,pd];
      func_keys: PICT_TYPE = [f1,f2,f3,f4,f5,f6,f7,f8,f9,f10];
var   str: CHAR; special,correct: BOOLEAN;
      temps: STR79;
BEGIN
  kchar:='';
  GETCHAR:=TRUE; correct:=FALSE;
  repeat { until getchar = TRUE }
  special:=TRUE;
  repeat { until a valid picture character }
  repeat until keypressed;
  read(kbd,kchar[1]);
  if keypressed and (kchar[1]=chr(esc)) then
  begin
    read(kbd,kchar[2]); kchar[1]:=chr(0);kchar[0]:=chr(2);
  end else
    kchar[0]:=chr(1);
{ Clear Line 25 }
  if clear25 then
  begin
    fillchar(temps,79,' ');
    color(7,0); gotoxy(1,25); writec(temps); gotoxy(hcol,lin);
    clear25:=FALSE; color(FGR_COLOR, BGR_COLOR);
  end;{ Clear Line }
  if (not (ord(kchar[1]) in [esc,cr,bk])) and (ord(kchar[0])=1) then
  begin
  str:=kchar[1];
  if (str>=' ') and (str<='~') then
  case ctype of
    'X': correct:=TRUE;
    'U': begin
         if str in ['a'..'z'] then str:=chr(ord(str) and $df);
         kchar[1]:=str; correct:=TRUE;
         end;
    'L': begin
         if str in ['A'..'Z'] then  str:=chr(ord(str) or $20);
         kchar[1]:=str; correct:=TRUE;
         end;
    '#': if  (str in ['0'..'9','-','.']) then correct:=TRUE else message(5);
    '9': if str in ['0'..'9',' '] then correct:=TRUE else message(2);
    '8': if str in ['0'..'9'] then correct:=TRUE else message(1);
  end { case  }
  end { begin }
  else
    begin {special character}
      GETCHAR:= FALSE; correct:=TRUE; str:=kchar[1];
    end;
  until correct;
  if (ord(kchar[0])=2) then  { see if it is a special character }
  begin
    special:=FALSE;
    GETCHAR:=TRUE;
    if (kchar[2] in special_keys) or (kchar[2] in func_keys) then
    begin
      GETCHAR:=FALSE; special:=TRUE;
    end else BEEP(BeepOnSS);
  end;
  until special;
  ret:=kchar;
END; { GETCHAR FUNCTION }

PROCEDURE DECH; { Positions Cursor At the Next Non Edit Character }
VAR elem_end: BOOLEAN; tempb1: BYTE;
BEGIN
if hcol<>(col+tcol-1) then
begin
  tempb1:=pcol; elem_end:=FALSE;
  repeat
    tempb1:=tempb1-1;if (pict[tempb1] in pict_elements) or (tempb1<1) then elem_end:=TRUE;
  until elem_end;
  if tempb1>=1 then begin hcol:=hcol-(pcol-tempb1);pcol:=tempb1;end;
end else
begin_of_field:=TRUE;
END; { DECH PROCEDURE }

PROCEDURE INCH; { Positions Cursor At the Next Non Edit Character }
VAR elem_end: BOOLEAN; tempb1: BYTE;
BEGIN
if hcol<>(col+len-1) then
begin
  tempb1:=1; elem_end:=FALSE;
  repeat
    tempb1:=tempb1+1;
    if (pict[pcol+tempb1-1] in pict_elements) or ((pcol+tempb1)>(len)) then elem_end:=TRUE;
  until elem_end;
  if tempb1<=(len) then  begin hcol:=hcol+tempb1-1; pcol:=pcol+tempb1-1; end;
end else
end_of_field:=TRUE;
END; { INCH PROCEDURE }

PROCEDURE STRIP_BLANKS(VAR temp_item: STR80);
{ Strip Blanks On Both Sides Of passed item }
VAR i,j: BYTE;
BEGIN
if temp_item<>'' then
begin
  j:=ord(temp_item[0]);
  { Strip Leading Blanks }
  i:=0; while (temp_item[i+1]=' ') and (i<j) do i:=i+1; { strip leading blanks }
  if (i>0) and (i<j) then temp_item:=copy(temp_item,i+1,j-i)
  else if (i=j) and (temp_item[j]=' ') then temp_item:='';
  i:=pos(' ',temp_item); { strip trailing blanks }
  if i<>0 then temp_item:=copy(temp_item,1,i-1);
end;
END; { STRIP_BLANKS PROCEDURE }

BEGIN { Main Procedure Of GETITEM }
item:=witem;   { Store Actual Item In A Work Variable }
clear25:=FALSE;
if itype='D' then begin pict:='88/88/88'; len:=8; end;
if itype='Y' then
begin
  if not (item[1] in ['Y','N']) then item:='Y'; pict:='U'; len:=1;
end;
if itype='M' then
begin
  if not (item[1] in ['M','F']) then item:='M'; pict:='U'; len:=1;
end;
end_of_field:=FALSE; begin_of_field:=FALSE;
if (pict='') and (itype='C') then pict:='X';
plen:=ord(pict[0]); fchar:=pict[plen]; ilen:=ord(item[0]);
{* Fill Item with blanks  *}
if itype<>'N'  then {* If item is non numeric *}
begin
  while ilen<len do  begin    item:=item+' '; ilen:=ilen+1;  end;
  while plen<len do  begin    pict:=pict+fchar; plen:=plen+1;  end;
end else {* If item is numeric *}
begin
  strip_blanks(item);
  if item='' then item:='0'; ilen:=ord(item[0]);
  while ilen<len do  begin item:=' '+item; ilen:=ilen+1; end;
  while plen<len do  begin pict:='#'+pict; plen:=plen+1; end;
  if ord(pict[0])>len then pict:=copy(pict,ord(pict[0])-len+1,len);
  if ord(item[0])>len then item:=copy(item,1,len);
  ilen:=ord(item[0]); plen:=ord(pict[0]);
  pict_dec:=pos('.',pict); item_dec:=pos('.',item);
{ Align Decimal Positions If Necessary }
if pict_dec<>item_dec then
begin { alignement }
check:=TRUE;
if (pict_dec=0) and check then { If picture has no decimal point and item does}
begin
  item:=copy(item,1,item_dec-1); fillchar(temp_item,ord(pict[0])-ord(item[0]),' ');
  item:=temp_item+item; check:=FALSE;
end;
if (item_dec=0) and check then { If item has no decimal point and pict does}
begin
  strip_blanks(item);
  tempb2:=plen-pict_dec; { # of decimal points };
  fillchar(temp_item,tempb2,item[ord(item[0])]);
  item:=item+'.'+temp_item; { Add decimal trailing digits }
  ilen:=ord(item[0]); { Get length of item }
  while ilen<plen do begin item:=' '+item; ilen:=ilen+1; end; { Add blanks left}
  if ilen>plen then { If The Item > Picture }
  begin
    item:=copy(item,1,pict_dec-1); item:=item+'.'+temp_item;
  end;
  check:=FALSE;
end;
if (item_dec>pict_dec) and check then { If item decimal is further right than pict dec}
begin { Move the item to the left dropping off numbers  picts}
  plen:=ord(pict[0]); ilen:=ord(item[0]);
  item:=copy(item,item_dec-pict_dec+1,ilen-(item_dec-pict_dec));
  ilen:=ord(item[0]); tempb1:=plen-ord(item[0]);
  fillchar(temp_item,tempb1,item[ilen]); item:=item+temp_item;
  ilen:=ord(item[0]);
  while ilen<plen do begin item:=' '+item; ilen:=ilen+1; end; { Add blanks left}
  check:=FALSE;
end;
if (pict_dec>item_dec) and check then { If pict decimal is further right than item's}
begin
  tempb2:=plen-pict_dec; item:=copy(item,1,item_dec+tempb2); ilen:=ord(item[0]);
  while ilen<len do begin item:=' '+item; ilen:=ilen+1; end; check:=FALSE;
end;
end { alignement };
end { fillings};
{* Copy edit characters to item *}
  for tempb1:=1 to len do
    if not (pict[tempb1] in pict_elements) then item[tempb1]:=pict[tempb1];
{* Display The item on the screen *}
  color(FGR_COLOR, BGR_COLOR);
  gotoxy(col,lin); writec(item);
{* Get Data From Screen If Retrieve is True}
if retrieve then
begin { Retrieve }
{* Move cursor to first position by bypassing edit chars }
  pcol:=1;
  while (not (pict[pcol] in pict_elements)) and (pcol<=len) do  pcol:=pcol+1;
{* Readjust column }
  tcol:=pcol;
{* Handle Non Numeric Type Of Item *}
if (itype<>'N') and (pcol<=len) then  { pcol is position of cursor within field}
begin {* Non Numeric Field *}
  repeat { Until range_check = TRUE }
  pcol:=tcol; hcol:=col+pcol-1;  gotoxy(hcol,lin); {* Go to location on screen*}
  repeat
    end_of_field:=FALSE; begin_of_field:=FALSE; special:=FALSE;
    if getchar(pict[pcol],kchar) then
    begin
      writec(kchar);item[pcol]:=kchar[1]; inch; gotoxy(hcol,lin);
    end else
    special:=TRUE;
    if special then
    begin { Special Key Pressed }
      ret:=kchar; special:=FALSE;
      if kchar[1]=chr(bk) then { It is backspace }
      begin
        dech; gotoxy(hcol,lin);  {Left}
      end else
      if (ord(kchar[0])=2) and (kchar[2] in [l,r,dl,ins]) then
      begin
        case kchar[2] of
       l: begin dech; gotoxy(hcol,lin); end; {Left}
       r: begin inch; gotoxy(hcol,lin); end; {Right}
      dl: begin {Delete}
            tempb2:=pcol+1; {FInd where the next edit char starts}
            while (pict[tempb2] in pict_elements) and (tempb2<=len) do
            tempb2:=tempb2+1; tempb2:=tempb2-1; { tempb1=start, tempb2:=end}
            for tempb1:=pcol to tempb2-1 do {move chars left}
            begin { & put blank at end} item[tempb1]:=item[tempb1+1]; end;
            item[tempb2]:=' ';
            {rewrite the item}
            gotoxy(col,lin);writec(item);gotoxy(hcol,lin);
          end;
     ins: begin {Insert}
            tempb2:=pcol+1;
            while (pict[tempb2] in pict_elements) and (tempb2<=len) do tempb2:=tempb2+1;
            tempb2:=tempb2-1;
            for tempb1:=tempb2 downto pcol+1 do
            begin item[tempb1]:=item[tempb1-1]; end;
            item[pcol]:=' '; gotoxy(col,lin);writec(item);gotoxy(hcol,lin);
          end;
          end { Case kchar };
        end
        else {esc,cr,pgup,pgdn,up,dn}
        special:=TRUE;
      end {If backspace };
      if end_of_field or begin_of_field then BEEP(BeepOnSS);
    until (end_of_field and (not confirm)) or begin_of_field or special;
    tempb1:=len; { Strip Trailing Blanks }
    if itype='C' then
      while (item[tempb1]=' ') and (tempb1>0) do tempb1:=tempb1-1;
    item[0]:=chr(tempb1); range_check:=TRUE;
    if itype='D' then
    begin
      range_check:=check_date(item,item_low,item_high);
      if not range_check then message(3);
    end;
    if itype='Y' then
      if not (item[1] in ['Y','N']) then
      begin
        range_check:=FALSE; message(6);
      end;
    if itype='M' then
      if not (item[1] in ['M','F']) then
      begin
        range_check:=FALSE; message(7);
      end;
  until range_check;
  end  { If non numeric type of item} else { if Numeric }
if (itype='N') then
begin
  tcol:=len;
  repeat { Until range_check=TRUE }
  len:=tcol;
  tempb1:=len; len:=pos('.',item); range_check:=FALSE;
  if len=0 then len:=tempb1 else len:=len-1;{ Item has decimal point }
  hcol:=col+len-1; pcol:=len; gotoxy(hcol,lin);
  special:=FALSE;  sign_flag:=FALSE;  end_of_field:=FALSE;  dec_flag:=FALSE;
  repeat
    valid_char:=FALSE;
    if getchar('#',kchar) then
    begin { Not Special }
    case kchar of
'-' : { Sign } if not sign_flag then valid_char:=TRUE;
'.' :  { Decimal point }
     if (len<>tempb1) and (not dec_flag) then
     begin
       hcol:=hcol+2; pcol:=len+2; gotoxy(hcol,lin);
       dec_flag:=TRUE; sign_flag:=TRUE;
     end;
'0'..'9': valid_char:=TRUE;
     end { Case kchar };
     { sign_flag = if FALSE we allow minus (-) sign }
     { dec_flag = if FALSE we allow decimal (.) point }
     if (valid_char) and (not dec_flag) then { Integer Portion }
     begin
       if (item[1]<>' ') and (len<>tempb1) and (sign_flag) then
         message(8) { Overflow Numeric Field }
       else
       begin
         if  (not sign_flag)  then  { Erase Old Entry. Start New One }
         begin                      { Sign Allowed }
           for pcol:=1 to len-1 do item[pcol]:=' ';
           if tempb1>len then
              for pcol:=len+2 to tempb1 do item[pcol]:='0';
           item[len]:=kchar; gotoxy(col,lin);
           writec(item); gotoxy(hcol,lin);
           if kchar[1]<>'0' then sign_flag:=TRUE;
         end else
         begin
           { Insert A Digit. No Sign Allowed }
           if not end_of_field then
             for pcol:=1 to len-1 do item[pcol]:=item[pcol+1];
           item[len]:=kchar; gotoxy(col,lin); writec(item); gotoxy(hcol,lin);
         end;
         if (item[1]<>' ') and (len=tempb1) then end_of_field:=TRUE;
       end;
     end { Integer Portion }
     else { Decimal Portion }
       if valid_char and (sign_flag) then
       begin
         item[pcol]:=kchar[1]; writec(item[pcol]);
         if not end_of_field then begin hcol:=hcol+1; pcol:=pcol+1 end;
         if pcol>tempb1 then
         begin hcol:=hcol-1; pcol:=pcol-1; end_of_field:=TRUE end;
         gotoxy(hcol,lin);
       end;
     end { getchar is FALSE } else { getchar is TRUE }
   special:=TRUE;
{ Special Keys. DEL}
   if special then
   begin
     ret:=kchar; special:=FALSE;
     if (ord(kchar[0])=2) then
     begin { Case }
     case kchar[2] of
 dl,l:{ DELETE KEY PRESSED OR LEFT ARROW KEY }
       case dec_flag of
  False: { Integer Portion }
       begin
         sign_flag:=TRUE;
         for pcol:=len downto 2 do item[pcol]:=item[pcol-1];
         if (item[len] in [' ','-']) then
         begin item[len]:='0'; sign_flag:=FALSE; end;
         item[1]:=' '; gotoxy(col,lin); writec(item);
         gotoxy(hcol,lin);
         end_of_field:=FALSE;
       end { F };
   True: { Decimal Portion }
   { Put 0 @ Cursor. Check If Going To Integer Part}
       if pict[pcol-1]='.' then  {Are We In Integer Part?}
       begin {YES. Initialize Variables}
         hcol:=col+len-1; gotoxy(hcol,lin); dec_flag:=FALSE;
         end_of_field:=FALSE;
       end else
       begin
         if not end_of_field then begin hcol:=hcol-1; pcol:=pcol-1 end;
         gotoxy(hcol,lin);item[pcol]:='0'; writec(item[pcol]); gotoxy(hcol,lin);
         end_of_field:=FALSE;
       end;
       { T }
     end { dec_flag CASE };
u,d,l,r,pu,pd,f1,f2,f3,f4,f5,f6,f7,f8,f9,f10: special:=TRUE;
   end; { DELETE KEY CASE }
  end { Case } else
  if (ord(kchar[1]) in [cr, esc]) then special:=TRUE;
end { Special };
if end_of_field and (not special) then BEEP(BeepOnSS);
until special or (end_of_field and (not confirm));
pcol:=pos('.',pict);
if (item[len] in [' ','-']) and (pcol=0) then
  begin  item[len]:='0';gotoxy(col,lin);writec(item);end
else
if (pcol>0) and (item[pcol-1] in [' ','-']) then
  begin  item[pcol-1]:='0'; gotoxy(col,lin);writec(item);end;
temp_item:=item;
strip_blanks(item);
range_check:=check_range(item,item_low,item_high);
if not range_check then begin message(4); item:=temp_item; end;
until range_check;
end;{ Numeric }
end { Retrieve } else
begin
  if itype='N' then strip_blanks(item);
  if itype='C' then
  begin
    tempb1:=len; { Strip Trailing Blanks }
    while (item[tempb1]=' ') and (tempb1>0) do tempb1:=tempb1-1;
    item[0]:=chr(tempb1);
  end;
end;
witem:=item; { Return result Back To witem }
END;{ GETITEM PROCEDURE}